home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / signal.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  12.6 KB  |  360 lines
  1. ;;; -*- Package: UNIX -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: signal.lisp,v 1.16 92/07/08 17:19:39 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: signal.lisp,v 1.16 92/07/08 17:19:39 ram Exp $
  15. ;;;
  16. ;;; Code for handling UNIX signals.
  17. ;;; 
  18. ;;; Written by William Lott.
  19. ;;;
  20.  
  21. (in-package "UNIX")
  22. (use-package "KERNEL")
  23. (export '(unix-signal-name unix-signal-description unix-signal-number
  24.       sigmask unix-sigblock unix-sigpause unix-sigsetmask unix-kill
  25.       unix-killpg))
  26.  
  27. (in-package "KERNEL")
  28. (export '(signal-init))
  29.  
  30. (in-package "SYSTEM")
  31. (export '(without-interrupts with-interrupts with-enabled-interrupts
  32.       enable-interrupt ignore-interrupt default-interrupt))
  33.  
  34. (in-package "UNIX")
  35.  
  36. ;;; These should probably be somewhere, but I don't know where.
  37. ;;; 
  38. (defconstant sig_dfl 0)
  39. (defconstant sig_ign 1)
  40.  
  41. (proclaim '(special lisp::lisp-command-line-list))
  42.  
  43.  
  44.  
  45. ;;;; Utilities for dealing with signal names and numbers.
  46.  
  47. (defstruct (unix-signal
  48.         (:constructor make-unix-signal (%name %number %description)))
  49.   %name                ; Signal keyword
  50.   (%number nil :type integer)       ; UNIX signal number
  51.   (%description nil :type string))  ; Documentation
  52.  
  53. (defvar *unix-signals* nil
  54.   "A list of unix signal structures.")
  55.  
  56. (eval-when (compile eval)
  57. (defmacro def-unix-signal (name number description)
  58.   (let ((symbol (intern (symbol-name name))))
  59.     `(progn
  60.        (push (make-unix-signal ,name ,number ,description) *unix-signals*)
  61.        ;; 
  62.        ;; This is to make the new signal lookup stuff compatible with
  63.        ;; old code which expects the symbol with the same print name as
  64.        ;; our keywords to be a constant with a value equal to the signal
  65.        ;; number.
  66.        (defconstant ,symbol ,number ,description)
  67.        (export ',symbol))))
  68. ) ;eval-when
  69.  
  70. (defun unix-signal-or-lose (arg)
  71.   (let ((signal (find arg *unix-signals*
  72.               :key (etypecase arg
  73.                  (symbol #'unix-signal-%name)
  74.                  (number #'unix-signal-%number)))))
  75.     (unless signal
  76.       (error "~S is not a valid signal name or number." arg))
  77.     signal))
  78.  
  79. (defun unix-signal-name (signal)
  80.   "Return the name of the signal as a string.  Signal should be a valid
  81.   signal number or a keyword of the standard UNIX signal name."
  82.   (symbol-name (unix-signal-%name (unix-signal-or-lose signal))))
  83.  
  84. (defun unix-signal-description (signal)
  85.   "Return a string describing signal.  Signal should be a valid signal
  86.   number or a keyword of the standard UNIX signal name."
  87.   (unix-signal-%description (unix-signal-or-lose signal)))
  88.  
  89. (defun unix-signal-number (signal)
  90.   "Return the number of the given signal.  Signal should be a valid
  91.   signal number or a keyword of the standard UNIX signal name."
  92.   (unix-signal-%number (unix-signal-or-lose signal)))
  93.  
  94. ;;; Known signals
  95. ;;; 
  96. (def-unix-signal :CHECK 0 "Check")
  97. (def-unix-signal :SIGHUP 1 "Hangup")
  98. (def-unix-signal :SIGINT 2 "Interrupt")
  99. (def-unix-signal :SIGQUIT 3 "Quit")
  100. (def-unix-signal :SIGILL 4 "Illegal instruction")
  101. (def-unix-signal :SIGTRAP 5 "Trace trap")
  102. (def-unix-signal :SIGIOT 6 "Iot instruction")
  103. (def-unix-signal :SIGEMT 7 "Emt instruction")
  104. (def-unix-signal :SIGFPE 8 "Floating point exception")
  105. (def-unix-signal :SIGKILL 9 "Kill")
  106. (def-unix-signal :SIGBUS 10 "Bus error")
  107. (def-unix-signal :SIGSEGV 11 "Segmentation violation")
  108. (def-unix-signal :SIGSYS 12 "Bad argument to system call")
  109. (def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
  110. (def-unix-signal :SIGALRM 14 "Alarm clock")
  111. (def-unix-signal :SIGTERM 15 "Software termination signal")
  112. (def-unix-signal :SIGURG 16 "Urgent condition present on socket")
  113. (def-unix-signal :SIGSTOP 17 "Stop")
  114. (def-unix-signal :SIGTSTP 18 "Stop signal generated from keyboard")
  115. (def-unix-signal :SIGCONT 19 "Continue after stop")
  116. (def-unix-signal :SIGCHLD 20 "Child status has changed")
  117. (def-unix-signal :SIGTTIN 21 "Background read attempted from control terminal")
  118. (def-unix-signal :SIGTTOU 22 "Background write attempted to control terminal")
  119. (def-unix-signal :SIGIO 23 "I/O is possible on a descriptor")
  120. (def-unix-signal :SIGXCPU 24 "Cpu time limit exceeded")
  121. (def-unix-signal :SIGXFSZ 25 "File size limit exceeded")
  122. (def-unix-signal :SIGVTALRM 26 "Virtual time alarm")
  123. (def-unix-signal :SIGPROF 27 "Profiling timer alarm")
  124. (def-unix-signal :SIGWINCH 28 "Window size change")
  125. (def-unix-signal :SIGUSR1 30 "User defined signal 1")
  126. (def-unix-signal :SIGUSR2 31 "User defined signal 2")
  127. ;;; 
  128. ;;; These are Mach Specific
  129. (def-unix-signal :SIGEMSG 30 "Mach Emergency message")
  130. (def-unix-signal :SIGMSG 31 "Mach message")
  131.  
  132. ;;; SIGMASK -- Public
  133. ;;;
  134. (defmacro sigmask (&rest signals)
  135.   "Returns a mask given a set of signals."
  136.   (apply #'logior
  137.      (mapcar #'(lambda (signal)
  138.              (ash 1 (1- (unix-signal-number signal))))
  139.          signals)))
  140.  
  141.  
  142. ;;;; System calls that deal with signals.
  143.  
  144. (proclaim '(inline real-unix-kill))
  145.  
  146. (alien:def-alien-routine ("kill" real-unix-kill) c-call:int
  147.   (pid c-call:int)
  148.   (signal c-call:int))
  149.  
  150. (defun unix-kill (pid signal)
  151.   "Unix-kill sends the signal signal to the process with process 
  152.    id pid.  Signal should be a valid signal number or a keyword of the
  153.    standard UNIX signal name."
  154.   (real-unix-kill pid (unix-signal-number signal)))
  155.  
  156.  
  157. (proclaim '(inline real-unix-killpg))
  158.  
  159. (alien:def-alien-routine ("killpg" real-unix-killpg) c-call:int
  160.   (pgrp c-call:int)
  161.   (signal c-call:int))
  162.  
  163. (defun unix-killpg (pgrp signal)
  164.   "Unix-killpg sends the signal signal to the all the process in process
  165.   group PGRP.  Signal should be a valid signal number or a keyword of
  166.   the standard UNIX signal name."
  167.   (real-unix-killpg pgrp (unix-signal-number signal)))
  168.  
  169.  
  170. (alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long
  171.   "Unix-sigblock cause the signals specified in mask to be
  172.    added to the set of signals currently being blocked from
  173.    delivery.  The macro sigmask is provided to create masks."
  174.   (mask c-call:unsigned-long))
  175.  
  176.  
  177. (alien:def-alien-routine ("sigpause" unix-sigpause) c-call:void
  178.   "Unix-sigpause sets the set of masked signals to its argument
  179.    and then waits for a signal to arrive, restoring the previous
  180.    mask upon its return."
  181.   (mask c-call:unsigned-long))
  182.  
  183.  
  184. (alien:def-alien-routine ("sigsetmask" unix-sigsetmask) c-call:unsigned-long
  185.   "Unix-sigsetmask sets the current set of masked signals (those
  186.    begin blocked from delivery) to the argument.  The macro sigmask
  187.    can be used to create the mask.  The previous value of the signal
  188.    mask is returned."
  189.   (mask c-call:unsigned-long))
  190.  
  191.  
  192.  
  193. ;;;; C routines that actually do all the work of establishing signal handlers.
  194.  
  195. (alien:def-alien-routine ("install_handler" install-handler)
  196.              c-call:unsigned-long
  197.   (signal c-call:int)
  198.   (handler c-call:unsigned-long))
  199.  
  200.  
  201.  
  202. ;;;; Interface to enabling and disabling signal handlers.
  203.  
  204. (defun enable-interrupt (signal handler)
  205.   (declare (type (or function (member :default :ignore)) handler))
  206.   (without-gcing
  207.    (let ((result (install-handler (unix-signal-number signal)
  208.                   (case handler
  209.                     (:default sig_dfl)
  210.                     (:ignore sig_ign)
  211.                     (t
  212.                      (kernel:get-lisp-obj-address handler))))))
  213.      (cond ((= result sig_dfl) :default)
  214.        ((= result sig_ign) :ignore)
  215.        (t (the function (kernel:make-lisp-obj result)))))))
  216.  
  217. (defun default-interrupt (signal)
  218.   (enable-interrupt signal :default))
  219.  
  220. (defun ignore-interrupt (signal)
  221.   (enable-interrupt signal :ignore))
  222.  
  223.  
  224.  
  225. ;;;; Default LISP signal handlers.
  226.  
  227. ;;; Most of these just call ERROR to report the presence of the signal.
  228.  
  229. (defmacro define-signal-handler (name what &optional (function 'error))
  230.   `(defun ,name (signal code scp)
  231.      (declare (ignore signal code)
  232.           (type system-area-pointer scp))
  233.      (system:without-hemlock
  234.       (,function ,(concatenate 'simple-string what " at #x~x.")
  235.          (with-alien ((scp (* sigcontext) scp))
  236.            (sap-int (slot scp 'sc-pc)))))))
  237.  
  238. (define-signal-handler sigint-handler "Interrupted" break)
  239. (define-signal-handler sigill-handler "Illegal Instruction")
  240. (define-signal-handler sigtrap-handler "Breakpoint/Trap")
  241. (define-signal-handler sigiot-handler "SIGIOT")
  242. (define-signal-handler sigemt-handler "SIGEMT")
  243. (define-signal-handler sigbus-handler "Bus Error")
  244. (define-signal-handler sigsegv-handler "Segmentation Violation")
  245. (define-signal-handler sigsys-handler "Bad Argument to a System Call")
  246. (define-signal-handler sigpipe-handler "SIGPIPE")
  247. (define-signal-handler sigalrm-handler "SIGALRM")
  248.  
  249. (defun sigquit-handler (signal code scp)
  250.   (declare (ignore signal code scp))
  251.   (throw 'lisp::top-level-catcher nil))
  252.  
  253. (defun signal-init ()
  254.   "Enable all the default signals that Lisp knows how to deal with."
  255.   (unless (member "-monitor" lisp::lisp-command-line-list :test #'string=)
  256.     (enable-interrupt :sigint #'sigint-handler))
  257.   (enable-interrupt :sigquit #'sigquit-handler)
  258.   (enable-interrupt :sigill #'sigill-handler)
  259.   (enable-interrupt :sigtrap #'sigtrap-handler)
  260.   (enable-interrupt :sigiot #'sigiot-handler)
  261.   (enable-interrupt :sigemt #'sigemt-handler)
  262.   (enable-interrupt :sigfpe #'vm:sigfpe-handler)
  263.   (enable-interrupt :sigbus #'sigbus-handler)
  264.   (enable-interrupt :sigsegv #'sigsegv-handler)
  265.   (enable-interrupt :sigsys #'sigsys-handler)
  266.   (enable-interrupt :sigpipe #'sigpipe-handler)
  267.   (enable-interrupt :sigalrm #'sigalrm-handler)
  268.   nil)
  269.  
  270.  
  271.  
  272. ;;;; Macros for dynamically enabling and disabling signal handling.
  273.  
  274. ;;; Notes on how the without-interrupts/with-interrupts stuff works.
  275. ;;;
  276. ;;; Before invoking the supplied handler for any of the signals that can be
  277. ;;; blocked, the C interrupt support code checks to see if *interrupts-enabled*
  278. ;;; has been bound to NIL.  If so, it saves the signal number and the value of
  279. ;;; the signal mask (from the sigcontext), sets the signal mask to block all
  280. ;;; blockable signals, sets *interrupt-pending* and returns without handling
  281. ;;; the signal.
  282. ;;;
  283. ;;; When we drop out the without interrupts, we check to see if
  284. ;;; *interrupt-pending* has been set.  If so, we call do-pending-interrupt,
  285. ;;; which generates a SIGTRAP.  The C code invokes the handler for the saved
  286. ;;; signal instead of the SIGTRAP after replacing the signal mask in the
  287. ;;; sigcontext with the saved value.  When that hander returns, the original
  288. ;;; signal mask is installed, allowing any other pending signals to be handled.
  289. ;;;
  290. ;;; This means that the cost of without-interrupts is just a special binding in
  291. ;;; the case when no signals are delivered (the normal case).  It's only when
  292. ;;; a signal is actually delivered that we use any system calls, and by then
  293. ;;; the cost of the extra system calls are lost in the noise when compared
  294. ;;; with the cost of delivering the signal in the first place.
  295. ;;;
  296.  
  297. (defvar *interrupts-enabled* t)
  298. (defvar *interrupt-pending* nil)
  299.  
  300. ;;; DO-PENDING-INTERRUPT  --  internal
  301. ;;;
  302. ;;; Magically converted by the compiler into a break instruction.
  303. ;;; 
  304. (defun do-pending-interrupt ()
  305.   (do-pending-interrupt))
  306.  
  307. ;;; WITHOUT-INTERRUPTS  --  puiblic
  308. ;;; 
  309. (defmacro without-interrupts (&body body)
  310.   "Execute BODY in a context impervious to interrupts."
  311.   (let ((name (gensym)))
  312.     `(flet ((,name () ,@body))
  313.        (if *interrupts-enabled*
  314.        (unwind-protect
  315.            (let ((*interrupts-enabled* nil))
  316.          (,name))
  317.          (when *interrupt-pending*
  318.            (do-pending-interrupt)))
  319.        (,name)))))
  320.  
  321. ;;; WITH-INTERRUPTS  --  puiblic
  322. ;;;
  323. (defmacro with-interrupts (&body body)
  324.   "Allow interrupts while executing BODY.  As interrupts are normally allowed,
  325.   this is only useful inside a WITHOUT-INTERRUPTS."
  326.   (let ((name (gensym)))
  327.     `(flet ((,name () ,@body))
  328.        (if *interrupts-enabled*
  329.        (,name)
  330.        (let ((*interrupts-enabled* t))
  331.          (when *interrupt-pending*
  332.            (do-pending-interrupt))
  333.          (,name))))))
  334.  
  335.  
  336. ;;;; WITH-ENABLED-INTERRUPTS
  337.  
  338. (defmacro with-enabled-interrupts (interrupt-list &body body)
  339.   "With-enabled-interrupts ({(interrupt function)}*) {form}*
  340.    Establish function as a handler for the Unix signal interrupt which
  341.    should be a number between 1 and 31 inclusive."
  342.   (let ((il (gensym))
  343.     (it (gensym)))
  344.     `(let ((,il NIL))
  345.        (unwind-protect
  346.        (progn
  347.          ,@(do* ((item interrupt-list (cdr item))
  348.              (intr (caar item) (caar item))
  349.              (ifcn (cadar item) (cadar item))
  350.              (forms NIL))
  351.             ((null item) (nreverse forms))
  352.          (when (symbolp intr)
  353.            (setq intr (symbol-value intr)))
  354.          (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
  355.                forms))
  356.          ,@body)
  357.      (dolist (,it (nreverse ,il))
  358.        (enable-interrupt (car ,it) (cadr ,it)))))))
  359.  
  360.